home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / hyperbole / kotl / kfill.el < prev    next >
Encoding:
Text File  |  1995-04-28  |  13.0 KB  |  370 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         kfill.el
  4. ;; SUMMARY:      Fill and justify koutline cells (adapted from Kyle Jones' filladapt).
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     outlines, wp
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORIG-DATE:    23-Jan-94
  10. ;; LAST-MOD:     17-Apr-95 at 11:53:55 by Bob Weiner
  11. ;;
  12. ;; This file is part of Hyperbole.
  13. ;; Available for use and distribution under the same terms as GNU Emacs.
  14. ;;
  15. ;; Copyright (C) 1994-1995, Free Software Foundation, Inc.
  16. ;; Developed with support from Motorola Inc.
  17. ;;
  18. ;; DESCRIPTION:  
  19. ;;
  20. ;; Based upon LCD Archive Entry:
  21. ;;   filladapt|Kyle E. Jones|kyle@crystal.wonderworks.com|
  22. ;;   Enhance Emacs fill commands to dynamically determine the fill prefix.|
  23. ;;   $Date: 1993/07/20 19:44:39 $|$Revision: 1.2 $|~/packages/filladapt.el.Z|
  24. ;;   Copyright (C) 1989 Kyle E. Jones
  25. ;;
  26. ;;   This package provides no muss, no fuss word wrapping and filling of
  27. ;;   paragraphs with hanging indents, included text from news and mail
  28. ;;   messages, and Lisp, C++, PostScript or shell comments.  It is table
  29. ;;   driven, so you can add your own favorites.
  30. ;;
  31. ;;   These functions enhance the default behavior of the Emacs'
  32. ;;   auto-fill-mode and the command fill-paragraph.  The chief improvement
  33. ;;   is that the beginning of a line to be filled is examined and
  34. ;;   appropriate values for fill-prefix, and the various paragraph-*
  35. ;;   variables are constructed and used during fills.  This occurs only if
  36. ;;   the fill prefix is not already non-nil.
  37. ;;
  38. ;;   The net result of this is that blurbs of text that are offset from
  39. ;;   left margin by asterisks, dashes, and/or spaces, numbered examples,
  40. ;;   included text from USENET news articles, etc. are generally filled
  41. ;;   correctly with no fuss.
  42. ;;
  43. ;; DESCRIP-END.
  44. ;;
  45. ;; MODS:
  46. ;;
  47. ;;   Bob Weiner, Motorola Inc., 8/11/93
  48. ;;     Added filladapt-hanging-p which uses current settings of hanging indent
  49. ;;       pattern (see filladapt-hanging-expression) to test if at a hanging
  50. ;;       indent.  Changed filladapt-hanging-list to use this function.
  51. ;;   Bob Weiner, Motorola Inc., 1/27/94
  52. ;;     Added removal of previous fill prefix before filling through
  53. ;;     'filladapt-replace-string' function.
  54. ;;
  55. ;;   20 July 1993: Patches to work with FSF GNU Emacs 19
  56. ;;                 Paul D. Smith <psmith@wellfleet.com>
  57. ;; END-MODS.
  58.  
  59.  
  60. ;;; ************************************************************************
  61. ;;; Public variables
  62. ;;; ************************************************************************
  63.  
  64. (defvar filladapt-function-table
  65.   (list (cons 'fill-paragraph (symbol-function 'fill-paragraph))
  66.     (cons 'do-auto-fill (symbol-function 'do-auto-fill)))
  67.   "Table containing the old function definitions that filladapt usurps.")
  68.  
  69. ;;; Prevent any old version of this variable from being used since it will
  70. ;;; not work properly with koutlines.
  71. (makunbound 'filladapt-prefix-table)
  72. (defvar filladapt-prefix-table
  73.   '(
  74.     ;; Lists with hanging indents, e.g.
  75.     ;; 1. xxxxx   or   1)  xxxxx   etc.
  76.     ;;    xxxxx            xxx
  77.     ;;
  78.     ;; Be sure pattern does not match to:  (last word in parens starts
  79.     ;; newline)
  80.     (" *(?\\([0-9][0-9a-z.]*\\|[a-z][0-9a-z.]\\)) +" . filladapt-hanging-list)
  81.     (" *\\([0-9]+[a-z.]+[0-9a-z.]*\\|[0-9]+\\|[a-z]\\)\\([.>] +\\|  +\\)"
  82.      . filladapt-hanging-list)
  83.     ;; Included text in news or mail replies
  84.     ("[ \t]*\\(>+ *\\)+" . filladapt-normal-included-text)
  85.     ;; Included text generated by SUPERCITE.  We can't hope to match all
  86.     ;; the possible variations, your mileage may vary.
  87.     ("[^'`\"< \t]*> *" . filladapt-supercite-included-text)
  88.     ;; Lisp comments
  89.     ("[ \t]*\\(;+[ \t]*\\)+" . filladapt-lisp-comment)
  90.     ;; UNIX shell comments
  91.     ("[ \t]*\\(#+[ \t]*\\)+" . filladapt-sh-comment)
  92.     ;; Postscript comments
  93.     ("[ \t]*\\(%+[ \t]*\\)+" . filladapt-postscript-comment)
  94.     ;; C++ comments
  95.     ("[ \t]*//[/ \t]*" . filladapt-c++-comment)
  96.     ("[?!~*+ -]+ " . filladapt-hanging-list)
  97.     ;; This keeps normal paragraphs from interacting unpleasantly with
  98.     ;; the types given above.
  99.     ("[^ \t/#%?!~*+-]" . filladapt-normal)
  100.     )
  101. "Value is an alist of the form
  102.  
  103.    ((REGXP . FUNCTION) ...)
  104.  
  105. When fill-paragraph or do-auto-fill is called, the REGEXP of each alist
  106. element is compared with the beginning of the current line.  If a match
  107. is found the corresponding FUNCTION is called.  FUNCTION is called with
  108. one argument, which is non-nil when invoked on the behalf of
  109. fill-paragraph, nil for do-auto-fill.  It is the job of FUNCTION to set
  110. the values of the paragraph-* variables (or set a clipping region, if
  111. paragraph-start and paragraph-separate cannot be made discerning enough)
  112. so that fill-paragraph and do-auto-fill work correctly in various
  113. contexts.")
  114.  
  115. ;;; ************************************************************************
  116. ;;; Public functions
  117. ;;; ************************************************************************
  118.  
  119. (defun do-auto-fill ()
  120.   (save-restriction
  121.     (if (null fill-prefix)
  122.     (let (fill-prefix)
  123.       (filladapt-adapt nil)
  124.       (filladapt-funcall 'do-auto-fill))
  125.       (filladapt-funcall 'do-auto-fill))))
  126.  
  127. (defun fill-paragraph (arg &optional skip-prefix-remove)
  128.   "Fill paragraph at or after point.  Prefix ARG means justify as well."
  129.   (interactive "*P")
  130.   (or skip-prefix-remove (filladapt-remove-paragraph-prefix))
  131.   (save-restriction
  132.     (catch 'done
  133.       (if (null fill-prefix)
  134.       (let (paragraph-ignore-fill-prefix
  135.         fill-prefix
  136.         (paragraph-start paragraph-start)
  137.         (paragraph-separate paragraph-separate))
  138.         (if (filladapt-adapt t)
  139.         (throw 'done (filladapt-funcall 'fill-paragraph arg)))))
  140.       ;; Filladapt-adapt failed or fill-prefix is set, so do a basic
  141.       ;; paragraph fill as adapted from par-align.el.
  142.       (filladapt-fill-paragraph arg skip-prefix-remove))))
  143.  
  144. ;;;
  145. ;;; Redefine this function so that it sets 'fill-prefix-prev' also.
  146. ;;;
  147. (defun set-fill-prefix (&optional turn-off)
  148.   "Set the fill-prefix to the current line up to point.
  149. Also sets fill-prefix-prev to previous value of fill-prefix.
  150. Filling expects lines to start with the fill prefix and reinserts the fill
  151. prefix in each resulting line."
  152.   (interactive)
  153.   (setq fill-prefix-prev fill-prefix
  154.     fill-prefix (if turn-off
  155.             nil
  156.               (buffer-substring
  157.                (save-excursion (beginning-of-line) (point))
  158.                (point))))
  159.   (if (equal fill-prefix-prev "")
  160.       (setq fill-prefix-prev nil))
  161.   (if (equal fill-prefix "")
  162.       (setq fill-prefix nil))
  163.   (if fill-prefix
  164.       (message "fill-prefix: \"%s\"" fill-prefix)
  165.     (message "fill-prefix cancelled")))
  166.  
  167. ;;; ************************************************************************
  168. ;;; Private functions
  169. ;;; ************************************************************************
  170.  
  171. (defun filladapt-adapt (paragraph)
  172.   (let ((table filladapt-prefix-table)
  173.     case-fold-search
  174.     success )
  175.     (save-excursion
  176.       (beginning-of-line)
  177.       (while table
  178.     (if (not (looking-at (car (car table))))
  179.         (setq table (cdr table))
  180.       (funcall (cdr (car table)) paragraph)
  181.       (setq success t table nil))))
  182.     success ))
  183.  
  184. (defun filladapt-c++-comment (paragraph)
  185.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  186.   (if paragraph
  187.       (setq paragraph-separate "^[^ \t/]")))
  188.  
  189. (defun filladapt-fill-paragraph (justify-flag &optional leave-prefix)
  190.   (save-excursion
  191.     (end-of-line)
  192.     ;; Backward to para begin
  193.     (re-search-backward (concat "\\`\\|" paragraph-separate))
  194.     (forward-line 1)
  195.     (let ((region-start (point)))
  196.       (forward-line -1)
  197.       (let ((from (point)))
  198.     (forward-paragraph)
  199.     ;; Forward to real paragraph end
  200.     (re-search-forward (concat "\\'\\|" paragraph-separate))
  201.     (or (= (point) (point-max)) (beginning-of-line))
  202.     (or leave-prefix
  203.         (filladapt-replace-string
  204.           (or fill-prefix fill-prefix-prev)
  205.           "" nil region-start (point)))
  206.     (fill-region-as-paragraph from (point) justify-flag)))))
  207.  
  208. (defun filladapt-funcall (function &rest args)
  209.   (apply (cdr (assq function filladapt-function-table)) args))
  210.  
  211. (defun filladapt-hanging-list (paragraph)
  212.   (let (prefix match beg end)
  213.     (setq prefix (make-string (- (match-end 0) (match-beginning 0)) ?\ ))
  214.     (if paragraph
  215.     (progn
  216.       (setq match (buffer-substring (match-beginning 0) (match-end 0)))
  217.       (if (string-match "^ +$" match)
  218.           (save-excursion
  219.         (while (and (not (bobp)) (looking-at prefix))
  220.           (forward-line -1))
  221.  
  222.         (cond ((filladapt-hanging-p)
  223.                (setq beg (point)))
  224.               (t (setq beg (progn (forward-line 1) (point))))))
  225.         (setq beg (point)))
  226.       (save-excursion
  227.         (forward-line)
  228.         (while (and (looking-at prefix)
  229.             (not (equal (char-after (match-end 0)) ?\ )))
  230.           (forward-line))
  231.         (setq end (point)))
  232.       (narrow-to-region beg end)))
  233.     (setq fill-prefix prefix)))
  234.  
  235. (defun filladapt-hanging-p ()
  236.   "Return non-nil iff point is in front of a hanging list."
  237.   (eval filladapt-hanging-expression))
  238.  
  239. (defun filladapt-lisp-comment (paragraph)
  240.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  241.   (if paragraph
  242.       (setq paragraph-separate
  243.         (concat "^" fill-prefix " *;\\|^"
  244.             (filladapt-negate-string fill-prefix)))))
  245.  
  246. (defun filladapt-negate-string (string)
  247.   (let ((len (length string))
  248.     (i 0) string-list)
  249.     (setq string-list (cons "\\(" nil))
  250.     (while (< i len)
  251.       (setq string-list
  252.         (cons (if (= i (1- len)) "" "\\|")
  253.           (cons "]"
  254.             (cons (substring string i (1+ i))
  255.                   (cons "[^"
  256.                     (cons (regexp-quote (substring string 0 i))
  257.                       string-list)))))
  258.         i (1+ i)))
  259.     (setq string-list (cons "\\)" string-list))
  260.     (apply 'concat (nreverse string-list))))
  261.  
  262. (defun filladapt-normal (paragraph)
  263.   (if paragraph
  264.       (setq paragraph-separate
  265.         (concat paragraph-separate "\\|^[ \t/#%?!~*+-]"))))
  266.  
  267. (defun filladapt-normal-included-text (paragraph)
  268.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  269.   (if paragraph
  270.       (setq paragraph-separate
  271.         (concat "^" fill-prefix " *>\\|^"
  272.             (filladapt-negate-string fill-prefix)))))
  273.  
  274. (defun filladapt-postscript-comment (paragraph)
  275.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  276.   (if paragraph
  277.       (setq paragraph-separate
  278.         (concat "^" fill-prefix " *%\\|^"
  279.             (filladapt-negate-string fill-prefix)))))
  280.  
  281. (defun filladapt-remove-paragraph-prefix (&optional indent-str)
  282.   "Remove fill prefix from current paragraph."
  283.   (save-excursion
  284.     (end-of-line)
  285.     ;; Backward to para begin
  286.     (re-search-backward (concat "\\`\\|" paragraph-separate))
  287.     (forward-line 1)
  288.     (let ((region-start (point)))
  289.       (forward-line -1)
  290.       (forward-paragraph)
  291.       ;; Forward to real paragraph end
  292.       (re-search-forward (concat "\\'\\|" paragraph-separate))
  293.       (or (= (point) (point-max)) (beginning-of-line))
  294.       (filladapt-replace-string (or fill-prefix fill-prefix-prev)
  295.                 (if (eq major-mode 'kotl-mode)
  296.                     (or indent-str
  297.                     (make-string (kcell-view:indent) ?  ))
  298.                   "")
  299.                 nil region-start (point)))))
  300.  
  301. (defun filladapt-replace-string (fill-str-prev fill-str &optional suffix start end)
  302.   "Replace whitespace separated FILL-STR-PREV with FILL-STR.
  303. Optional SUFFIX non-nil means replace at ends of lines, default is beginnings.
  304. Optional arguments START and END specify the replace region, default is the
  305. current region."
  306.   (if fill-str-prev
  307.       (progn (if start
  308.          (let ((s (min start end)))
  309.            (setq end (max start end)
  310.              start s))
  311.            (setq start (region-beginning)
  312.              end (region-end)))
  313.          (if (not fill-str) (setq fill-str ""))
  314.          (save-excursion
  315.            (save-restriction
  316.          (narrow-to-region start end)
  317.          (goto-char (point-min))
  318.          (let ((prefix
  319.             (concat
  320.              (if suffix nil "^")
  321.              "[ \t]*"
  322.              (regexp-quote
  323.               ;; Get non-whitespace separated fill-str-prev
  324.               (substring
  325.                fill-str-prev
  326.                (or (string-match "[^ \t]" fill-str-prev) 0)
  327.                (if (string-match
  328.                 "[ \t]*\\(.*[^ \t]\\)[ \t]*$"
  329.                 fill-str-prev)
  330.                    (match-end 1))))
  331.              "[ \t]*"
  332.              (if suffix "$"))))
  333.            (while (re-search-forward prefix nil t)
  334.              (replace-match fill-str nil t))))))))
  335.  
  336. (defun filladapt-sh-comment (paragraph)
  337.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  338.   (if paragraph
  339.       (setq paragraph-separate
  340.         (concat "^" fill-prefix " *#\\|^"
  341.             (filladapt-negate-string fill-prefix)))))
  342.  
  343. (defun filladapt-supercite-included-text (paragraph)
  344.   (setq fill-prefix (buffer-substring (match-beginning 0) (match-end 0)))
  345.   (if paragraph
  346.       (setq paragraph-separate
  347.         (concat "^" (filladapt-negate-string fill-prefix)))))
  348.  
  349. ;;; ************************************************************************
  350. ;;; Private variables
  351. ;;; ************************************************************************
  352.  
  353. (defconst filladapt-hanging-expression
  354.   (cons 'or
  355.     (delq nil (mapcar (function
  356.                 (lambda (pattern-type)
  357.                   (if (eq (cdr pattern-type) 'filladapt-hanging-list)
  358.                   (list 'looking-at (car pattern-type)))))
  359.               filladapt-prefix-table)))
  360.   "Conditional expression used to test for hanging indented lists.")
  361.  
  362. (defvar fill-prefix-prev nil
  363.   "Prior string inserted at front of new line during filling, or nil for none.
  364. Setting this variable automatically makes it local to the current buffer.")
  365. (make-variable-buffer-local 'fill-prefix-prev)
  366.  
  367.  
  368. (provide 'kfill)
  369. (provide 'filladapt)
  370.